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SYN1A 


o 




1 






1 (stage requested-loops) 

2 (projection key :defined-on requested-loops) 

3 (projection computing-loop :defined-on requested-loops) 

4 (define test 

5 (lambda (x y z) 

6 (and! (and! X y) z))) 

7 (define and! 

8 (reduction-stage requested-loops 

9 (lambda (argl arg2) 

10 (pointwise #'and argl arg2)))) 

1 1 (propagator requested-loops :bottom-up 

12 (lambda (term) 

1 3 (case requested-loops term 

14 ((pointwise op argl arg2) (op argl arg2) 

1 5 (let ((starting-loop 

16 (fuse-loops (get-or-make-loop argl) (get-or-make-loop arg2)) 

17 (my-key (gensym))) 

1 8 (deconstruct requested-loops starting-loop 

19 (ptw-loop fn inputs outputs) (fn inputs outputs) 

20 (let* ((new-fn (reduction-stage computation 

2 1 (lambda (args) 

22 (let* ((temp (fn args)) 

23 (result 

24 (op (find (key arg 1 ) temp) 

25 (find (key arg2) temp)))) 

26 (cons (cons my-key result) 

27 temp)))) 

28 (new-loop (defer (ptw-loop new-fn inputs outputs)))) 

29 (update (key value) my-key) 

30 (update (computing-loop value) new-loop)) 

3 1 (if (computing-loop arg 1 ) 

32 (update (computing-loop argl) 

33 (defer (loop-reference value)))) 

34 (if (computing-loop arg2) 

35 (update (computing-loop arg2) 

36 (defer (loop-reference value)))))))) 

37 (else (note-demands value) 

38 ))) 
39 
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39 (define get-or-make-loop (value) 

40 (if (and (same-frequency value) (computing-loop value)) 

41 (get-loop value) 

42 (defer (ptw-loop 

43 (reduction-stage computation 

44 (lambda (args) args) 

45 (list (cons (key value) value)) 

46 nil)))) 

47 (define get-loop 

48 (reduction-stage computation 

49 (lambda (value) 

50 (computing-loop (get-loop-location value)))) 

5 1 (define get-loop-location 

52 (reduction-stage computation 

53 (lambda (value) 

54 (case requested-loops (computing-loop value) 

55 ((loop-reference next) (next) 

56 (get-loop-location next)) 

57 (else value)))) 

58 (define note-demands (value) 

59 (case requested-loops value 

60 ((fn . args) (fn args) 

61 (record-demand fn) 

62 (map args #record-demand)) 

63 ((case stage value (pattern vars body) (else otherwise)) 

64 (stage value pattern vars body otherwise) 

65 (record-demand value) 

66 (record-demand body) 

67 (record-demand otherwise)) 

68 ((lambda vars body) (vars body) 

69 (record-demand body)))) 

70 (define record-demand (value) 

71 (if (computing-loop value) 

72 (let ((place (get-loop-location value)) 

73 (key (key value))) 

74 (case requested-loops (computing-loop place) 

75 ((ptw fn inputs outputs) (fn inputs outputs) 

76 (if (not (member key outputs)) 

77 (let ((new-outputs (cons key outputs))) 

78 (update (computing-loop place) 

79 (delay (ptw fn inputs new-outputs)))))))))) 
80 
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80 
81 


(define ptw-loop 
(lambda (fn inputs outputs) 




82 


(let ((output-pairs (early-mapcar (reduction-stage computation 




83 


(lambda (key) (cons key (new-array))) 




84 


outputs)))) 




85 


(dotimes ((i 0 99)) 




86 


(let* ((input-scalars 




87 
88 
89 


(early-mapcar (reduction-stage computation 
(lambda (pair) 
(let ((key (first pair)) 




90 


(array (second pair))) 




91 


(cons key (elt array i) 




92 


inputs)) 




93 


(output-scalars (fn input-scalars))) 




94 


(early-map (reduction-stage computation 




95 


(lambda (pair) 




96 


(let ((key (first pair)) 




97 


(array (second pair))) 




98 


(setf (elt array i) 


:i y 


99 


(find key output-scalars)))) 


i ' i 


100 


output-pairs)))))) 


i=y 


101 


(define pointwise (fn op 1 op2 — > result) 


!L 


102 


(reduction-stage computation \\ inlineable after loop fusion 


L 


103 


(find (key result) (get-loop result)))) 




104 


(define fuse-loops 


o 


105 


(lambda (loopl loop2) 




106 


(if (stage-eq requested-loops loopl loop2) 




107 


loopl 




108 


(deconstruct loop-structure loopl 




109 


((ptw-loop fill inputssl outputs 1) (fnl inputs 1 outputs 1) 




110 


(deconstruct loop-structure loop2 




111 


((ptw-loop fn2 inputs2 outputs2) (fn2 inputs2 outputs2) 




112 


(let ((inputs (merge inputs 1 inputs2)) 




113 


(outputs (append outputs 1 outputs2))) 






(ptw-loop 




115 


(preserves computation 




116 
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inputs outputs))))))))) 




118 


(define find 




119 


(reduction-stage computation ;; inlineable after loop fusion 




120 


(lambda (id list) 




121 


(deconstruct computation list 




122 


(cons (cons key value) rest) (key value rest) 




123 


(if (stage-eq computation key id) 




124 


value 




125 


(find id rest)))))) 




126 


(define merge 




127 


... like find 
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